home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / generic / tclFCmd.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-15  |  22.3 KB  |  816 lines  |  [TEXT/CWIE]
  1. /*
  2.  * tclFCmd.c
  3.  *
  4.  *      This file implements the generic portion of file manipulation 
  5.  *      subcommands of the "file" command. 
  6.  *
  7.  * Copyright (c) 1996-1997 Sun Microsystems, Inc.
  8.  *
  9.  * See the file "license.terms" for information on usage and redistribution
  10.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11.  *
  12.  * SCCS: @(#) tclFCmd.c 1.17 97/05/14 13:23:13
  13.  */
  14.  
  15. #include "tclInt.h"
  16. #include "tclPort.h"
  17.  
  18. /*
  19.  * Declarations for local procedures defined in this file:
  20.  */
  21.  
  22. static int        CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp,
  23.                 char *source, char *dest, int copyFlag,
  24.                 int force));
  25. static char *        FileBasename _ANSI_ARGS_((Tcl_Interp *interp,
  26.                 char *path, Tcl_DString *bufferPtr));
  27. static int        FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp,
  28.                 int argc, char **argv, int copyFlag));
  29. static int        FileForceOption _ANSI_ARGS_((Tcl_Interp *interp,
  30.                 int argc, char **argv, int *forcePtr));
  31.  
  32. /*
  33.  *---------------------------------------------------------------------------
  34.  *
  35.  * TclFileRenameCmd
  36.  *
  37.  *    This procedure implements the "rename" subcommand of the "file"
  38.  *      command.  Filename arguments need to be translated to native
  39.  *    format before being passed to platform-specific code that
  40.  *    implements rename functionality.
  41.  *
  42.  * Results:
  43.  *    A standard Tcl result.
  44.  *
  45.  * Side effects:
  46.  *    See the user documentation.
  47.  *
  48.  *---------------------------------------------------------------------------
  49.  */
  50.  
  51. int
  52. TclFileRenameCmd(interp, argc, argv)
  53.     Tcl_Interp *interp;        /* Interp for error reporting. */
  54.     int argc;            /* Number of arguments. */
  55.     char **argv;        /* Argument strings passed to Tcl_FileCmd. */
  56. {
  57.     return FileCopyRename(interp, argc, argv, 0);
  58. }
  59.  
  60. /*
  61.  *---------------------------------------------------------------------------
  62.  *
  63.  * TclFileCopyCmd
  64.  *
  65.  *    This procedure implements the "copy" subcommand of the "file"
  66.  *    command.  Filename arguments need to be translated to native
  67.  *    format before being passed to platform-specific code that
  68.  *    implements copy functionality.
  69.  *
  70.  * Results:
  71.  *    A standard Tcl result.
  72.  *
  73.  * Side effects:
  74.  *    See the user documentation.
  75.  *
  76.  *---------------------------------------------------------------------------
  77.  */
  78.  
  79. int
  80. TclFileCopyCmd(interp, argc, argv)
  81.     Tcl_Interp *interp;        /* Used for error reporting */
  82.     int argc;            /* Number of arguments. */
  83.     char **argv;        /* Argument strings passed to Tcl_FileCmd. */
  84. {
  85.     return FileCopyRename(interp, argc, argv, 1);
  86. }
  87.  
  88. /*
  89.  *---------------------------------------------------------------------------
  90.  *
  91.  * FileCopyRename --
  92.  *
  93.  *    Performs the work of TclFileRenameCmd and TclFileCopyCmd.
  94.  *    See comments for those procedures.
  95.  *
  96.  * Results:
  97.  *    See above.
  98.  *
  99.  * Side effects:
  100.  *    See above.
  101.  *
  102.  *---------------------------------------------------------------------------
  103.  */
  104.  
  105. static int
  106. FileCopyRename(interp, argc, argv, copyFlag)
  107.     Tcl_Interp *interp;        /* Used for error reporting. */
  108.     int argc;            /* Number of arguments. */
  109.     char **argv;        /* Argument strings passed to Tcl_FileCmd. */
  110.     int copyFlag;        /* If non-zero, copy source(s).  Otherwise,
  111.                  * rename them. */
  112. {
  113.     int i, result, force;
  114.     struct stat statBuf; 
  115.     Tcl_DString targetBuffer;
  116.     char *target;
  117.  
  118.     i = FileForceOption(interp, argc - 2, argv + 2, &force);
  119.     if (i < 0) {
  120.     return TCL_ERROR;
  121.     }
  122.     i += 2;
  123.     if ((argc - i) < 2) {
  124.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  125.         " ", argv[1], " ?options? source ?source ...? target\"", 
  126.         (char *) NULL);
  127.     return TCL_ERROR;
  128.     }
  129.  
  130.     /*
  131.      * If target doesn't exist or isn't a directory, try the copy/rename.
  132.      * More than 2 arguments is only valid if the target is an existing
  133.      * directory.
  134.      */
  135.  
  136.     target = Tcl_TranslateFileName(interp, argv[argc - 1], &targetBuffer);
  137.     if (target == NULL) {
  138.     return TCL_ERROR;
  139.     }
  140.  
  141.     result = TCL_OK;
  142.  
  143.     /*
  144.      * Call stat() so that if target is a symlink that points to a directory
  145.      * we will put the sources in that directory instead of overwriting the
  146.      * symlink.
  147.      */
  148.  
  149.     if ((stat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) {
  150.     if ((argc - i) > 2) {
  151.         errno = ENOTDIR;
  152.         Tcl_PosixError(interp);
  153.         Tcl_AppendResult(interp, "error ",
  154.             ((copyFlag) ? "copying" : "renaming"), ": target \"",
  155.             argv[argc - 1], "\" is not a directory", (char *) NULL);
  156.         result = TCL_ERROR;
  157.     } else {
  158.         /*
  159.          * Even though already have target == translated(argv[i+1]),
  160.          * pass the original argument down, so if there's an error, the
  161.          * error message will reflect the original arguments.
  162.          */
  163.  
  164.         result = CopyRenameOneFile(interp, argv[i], argv[i + 1], copyFlag,
  165.             force);
  166.     }
  167.     Tcl_DStringFree(&targetBuffer);
  168.     return result;
  169.     }
  170.     
  171.     /*
  172.      * Move each source file into target directory.  Extract the basename
  173.      * from each source, and append it to the end of the target path.
  174.      */
  175.     
  176.     for ( ; i < argc - 1; i++) {
  177.     char *jargv[2];
  178.     char *source, *newFileName;
  179.     Tcl_DString sourceBuffer, newFileNameBuffer;
  180.  
  181.     source = FileBasename(interp, argv[i], &sourceBuffer);
  182.     if (source == NULL) {
  183.         result = TCL_ERROR;
  184.         break;
  185.     }
  186.     jargv[0] = argv[argc - 1];
  187.     jargv[1] = source;
  188.     Tcl_DStringInit(&newFileNameBuffer);
  189.     newFileName = Tcl_JoinPath(2, jargv, &newFileNameBuffer);
  190.     result = CopyRenameOneFile(interp, argv[i], newFileName, copyFlag,
  191.         force);
  192.     Tcl_DStringFree(&sourceBuffer);
  193.     Tcl_DStringFree(&newFileNameBuffer);
  194.  
  195.     if (result == TCL_ERROR) {
  196.         break;
  197.     }
  198.     }
  199.     Tcl_DStringFree(&targetBuffer);
  200.     return result;
  201. }
  202.  
  203. /*
  204.  *---------------------------------------------------------------------------
  205.  *
  206.  * TclFileMakeDirsCmd
  207.  *
  208.  *    This procedure implements the "mkdir" subcommand of the "file"
  209.  *      command.  Filename arguments need to be translated to native
  210.  *    format before being passed to platform-specific code that
  211.  *    implements mkdir functionality.
  212.  *
  213.  * Results:
  214.  *    A standard Tcl result.
  215.  *
  216.  * Side effects:
  217.  *    See the user documentation.
  218.  *
  219.  *----------------------------------------------------------------------
  220.  */
  221. int
  222. TclFileMakeDirsCmd(interp, argc, argv)
  223.     Tcl_Interp *interp;        /* Used for error reporting. */
  224.     int argc;            /* Number of arguments */
  225.     char **argv;        /* Argument strings passed to Tcl_FileCmd. */
  226. {
  227.     Tcl_DString nameBuffer, targetBuffer;
  228.     char *errfile;
  229.     int result, i, j, pargc;
  230.     char **pargv;
  231.     struct stat statBuf;
  232.  
  233.     pargv = NULL;
  234.     errfile = NULL;
  235.     Tcl_DStringInit(&nameBuffer);
  236.     Tcl_DStringInit(&targetBuffer);
  237.  
  238.     result = TCL_OK;
  239.     for (i = 2; i < argc; i++) {
  240.     char *name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer);
  241.     if (name == NULL) {
  242.         result = TCL_ERROR;
  243.         break;
  244.     }
  245.  
  246.     Tcl_SplitPath(name, &pargc, &pargv);
  247.     if (pargc == 0) {
  248.         errno = ENOENT;
  249.         errfile = argv[i];
  250.         break;
  251.     }
  252.     for (j = 0; j < pargc; j++) {
  253.         char *target = Tcl_JoinPath(j + 1, pargv, &targetBuffer);
  254.  
  255.         /*
  256.          * Call stat() so that if target is a symlink that points to a
  257.          * directory we will create subdirectories in that directory.
  258.          */
  259.  
  260.         if (stat(target, &statBuf) == 0) {
  261.         if (!S_ISDIR(statBuf.st_mode)) {
  262.             errno = EEXIST;
  263.             errfile = target;
  264.             goto done;
  265.         }
  266.         } else if ((errno != ENOENT)
  267.             || (TclpCreateDirectory(target) != TCL_OK)) {
  268.         errfile = target;
  269.         goto done;
  270.         }
  271.         Tcl_DStringFree(&targetBuffer);
  272.     }
  273.     ckfree((char *) pargv);
  274.     pargv = NULL;
  275.     Tcl_DStringFree(&nameBuffer);
  276.     }
  277.     
  278.     done:
  279.     if (errfile != NULL) {
  280.     Tcl_AppendResult(interp, "can't create directory \"",
  281.         errfile, "\": ", Tcl_PosixError(interp), (char *) NULL);
  282.     result = TCL_ERROR;
  283.     }
  284.  
  285.     Tcl_DStringFree(&nameBuffer);
  286.     Tcl_DStringFree(&targetBuffer);
  287.     if (pargv != NULL) {
  288.     ckfree((char *) pargv);
  289.     }
  290.     return result;
  291. }
  292.  
  293. /*
  294.  *----------------------------------------------------------------------
  295.  *
  296.  * TclFileDeleteCmd
  297.  *
  298.  *    This procedure implements the "delete" subcommand of the "file"
  299.  *      command.
  300.  *
  301.  * Results:
  302.  *    A standard Tcl result.
  303.  *
  304.  * Side effects:
  305.  *    See the user documentation.
  306.  *
  307.  *----------------------------------------------------------------------
  308.  */
  309.  
  310. int
  311. TclFileDeleteCmd(interp, argc, argv)
  312.     Tcl_Interp *interp;        /* Used for error reporting */
  313.     int argc;            /* Number of arguments */
  314.     char **argv;        /* Argument strings passed to Tcl_FileCmd. */
  315. {
  316.     Tcl_DString nameBuffer, errorBuffer;
  317.     int i, force, result;
  318.     char *errfile;
  319.     
  320.     i = FileForceOption(interp, argc - 2, argv + 2, &force);
  321.     if (i < 0) {
  322.     return TCL_ERROR;
  323.     }
  324.     i += 2;
  325.     if ((argc - i) < 1) {
  326.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  327.         " ", argv[1], " ?options? file ?file ...?\"", (char *) NULL);
  328.     return TCL_ERROR;
  329.     }
  330.  
  331.     errfile = NULL;
  332.     result = TCL_OK;
  333.     Tcl_DStringInit(&errorBuffer);
  334.     Tcl_DStringInit(&nameBuffer);
  335.  
  336.     for ( ; i < argc; i++) {
  337.     struct stat statBuf;
  338.     char *name;
  339.  
  340.     errfile = argv[i];
  341.     Tcl_DStringSetLength(&nameBuffer, 0);
  342.     name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer);
  343.     if (name == NULL) {
  344.         result = TCL_ERROR;
  345.         goto done;
  346.     }
  347.  
  348.     /*
  349.      * Call lstat() to get info so can delete symbolic link itself.
  350.      */
  351.  
  352.     if (lstat(name, &statBuf) != 0) {
  353.         /*
  354.          * Trying to delete a file that does not exist is not
  355.          * considered an error, just a no-op
  356.          */
  357.  
  358.         if (errno != ENOENT) {
  359.         result = TCL_ERROR;
  360.         }
  361.     } else if (S_ISDIR(statBuf.st_mode)) {
  362.         result = TclpRemoveDirectory(name, force, &errorBuffer);
  363.         if (result != TCL_OK) {
  364.         if ((force == 0) && (errno == EEXIST)) {
  365.             Tcl_AppendResult(interp, "error deleting \"", argv[i],
  366.                 "\": directory not empty", (char *) NULL);
  367.             Tcl_PosixError(interp);
  368.             goto done;
  369.         }
  370.  
  371.         /* 
  372.          * If possible, use the untranslated name for the file.
  373.          */
  374.          
  375.         errfile = Tcl_DStringValue(&errorBuffer);
  376.         if (strcmp(name, errfile) == 0) {
  377.             errfile = argv[i];
  378.         }
  379.         }
  380.     } else {
  381.         result = TclpDeleteFile(name);
  382.     }
  383.     
  384.     if (result == TCL_ERROR) {
  385.         break;
  386.     }
  387.     }
  388.     if (result != TCL_OK) {
  389.     Tcl_AppendResult(interp, "error deleting \"", errfile,
  390.         "\": ", Tcl_PosixError(interp), (char *) NULL);
  391.     } 
  392.     done:
  393.     Tcl_DStringFree(&errorBuffer);
  394.     Tcl_DStringFree(&nameBuffer);
  395.     return result;
  396. }
  397.  
  398. /*
  399.  *---------------------------------------------------------------------------
  400.  *
  401.  * CopyRenameOneFile
  402.  *
  403.  *    Copies or renames specified source file or directory hierarchy
  404.  *    to the specified target.  
  405.  *
  406.  * Results:
  407.  *    A standard Tcl result.
  408.  *
  409.  * Side effects:
  410.  *    Target is overwritten if the force flag is set.  Attempting to
  411.  *    copy/rename a file onto a directory or a directory onto a file
  412.  *    will always result in an error.  
  413.  *
  414.  *----------------------------------------------------------------------
  415.  */
  416.  
  417. static int
  418. CopyRenameOneFile(interp, source, target, copyFlag, force) 
  419.     Tcl_Interp *interp;        /* Used for error reporting. */
  420.     char *source;        /* Pathname of file to copy.  May need to
  421.                  * be translated. */
  422.     char *target;        /* Pathname of file to create/overwrite.
  423.                  * May need to be translated. */
  424.     int copyFlag;        /* If non-zero, copy files.  Otherwise,
  425.                  * rename them. */
  426.     int force;            /* If non-zero, overwrite target file if it
  427.                  * exists.  Otherwise, error if target already
  428.                  * exists. */
  429. {
  430.     int result;
  431.     Tcl_DString sourcePath, targetPath, errorBuffer;
  432.     char *targetName, *sourceName, *errfile;
  433.     struct stat sourceStatBuf, targetStatBuf;
  434.     
  435.     sourceName = Tcl_TranslateFileName(interp, source, &sourcePath);
  436.     if (sourceName == NULL) {
  437.     return TCL_ERROR;
  438.     }
  439.     targetName = Tcl_TranslateFileName(interp, target, &targetPath);
  440.     if (targetName == NULL) {
  441.     Tcl_DStringFree(&sourcePath);
  442.     return TCL_ERROR;
  443.     }
  444.     
  445.     errfile = NULL;
  446.     result = TCL_ERROR;
  447.     Tcl_DStringInit(&errorBuffer);
  448.     
  449.     /*
  450.      * We want to copy/rename links and not the files they point to, so we
  451.      * use lstat(). If target is a link, we also want to replace the 
  452.      * link and not the file it points to, so we also use lstat() on the
  453.      * target.
  454.      */
  455.  
  456.     if (lstat(sourceName, &sourceStatBuf) != 0) {
  457.     errfile = source;
  458.     goto done;
  459.     }
  460.     if (lstat(targetName, &targetStatBuf) != 0) {
  461.     if (errno != ENOENT) {
  462.         errfile = target;
  463.         goto done;
  464.     }
  465.     } else {
  466.     if (force == 0) {
  467.         errno = EEXIST;
  468.         errfile = target;
  469.         goto done;
  470.     }
  471.  
  472.         /* 
  473.          * Prevent copying or renaming a file onto itself.  Under Windows, 
  474.          * stat always returns 0 for st_ino.  However, the Windows-specific 
  475.          * code knows how to deal with copying or renaming a file on top of
  476.          * itself.  It might be a good idea to write a stat that worked.
  477.          */
  478.      
  479.         if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) {
  480.             if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) &&
  481.                     (sourceStatBuf.st_dev == targetStatBuf.st_dev)) {
  482.                 result = TCL_OK;
  483.                 goto done;
  484.             }
  485.         }
  486.  
  487.     /*
  488.      * Prevent copying/renaming a file onto a directory and
  489.      * vice-versa.  This is a policy decision based on the fact that
  490.      * existing implementations of copy and rename on all platforms
  491.      * also prevent this.
  492.      */
  493.  
  494.     if (S_ISDIR(sourceStatBuf.st_mode)
  495.                 && !S_ISDIR(targetStatBuf.st_mode)) {
  496.         errno = EISDIR;
  497.         Tcl_AppendResult(interp, "can't overwrite file \"", target,
  498.             "\" with directory \"", source, "\"", (char *) NULL);
  499.         goto done;
  500.     }
  501.     if (!S_ISDIR(sourceStatBuf.st_mode)
  502.             && S_ISDIR(targetStatBuf.st_mode)) {
  503.         errno = EISDIR;
  504.         Tcl_AppendResult(interp, "can't overwrite directory \"", target, 
  505.                 "\" with file \"", source, "\"", (char *) NULL);
  506.         goto done;
  507.     }
  508.     }
  509.  
  510.     if (copyFlag == 0) {
  511.     result = TclpRenameFile(sourceName, targetName);
  512.     if (result == TCL_OK) {
  513.         goto done;
  514.     }
  515.         
  516.     if (errno == EINVAL) {
  517.         Tcl_AppendResult(interp, "error renaming \"", source, "\" to \"",
  518.             target, "\": trying to rename a volume or ",
  519.             "move a directory into itself", (char *) NULL);
  520.         goto done;
  521.     } else if (errno != EXDEV) {
  522.         errfile = target;
  523.         goto done;
  524.     }
  525.     
  526.     /*
  527.      * The rename failed because the move was across file systems.
  528.      * Fall through to copy file and then remove original.  Note that
  529.      * the low-level TclpRenameFile is allowed to implement
  530.      * cross-filesystem moves itself.
  531.      */
  532.     }
  533.  
  534.     if (S_ISDIR(sourceStatBuf.st_mode)) {
  535.     result = TclpCopyDirectory(sourceName, targetName, &errorBuffer);
  536.     if (result != TCL_OK) {
  537.         errfile = Tcl_DStringValue(&errorBuffer);
  538.         if (strcmp(errfile, sourceName) == 0) {
  539.         errfile = source;
  540.         } else if (strcmp(errfile, targetName) == 0) {
  541.         errfile = target;
  542.         }
  543.     }
  544.     } else {
  545.     result = TclpCopyFile(sourceName, targetName);
  546.     if (result != TCL_OK) {
  547.         /*
  548.          * Well, there really shouldn't be a problem with source,
  549.          * because up there we checked to see if it was ok to copy it.
  550.          */
  551.  
  552.         errfile = target;
  553.     }
  554.     }
  555.     if ((copyFlag == 0) && (result == TCL_OK)) {
  556.     if (S_ISDIR(sourceStatBuf.st_mode)) {
  557.         result = TclpRemoveDirectory(sourceName, 1, &errorBuffer);
  558.         if (result != TCL_OK) {
  559.         errfile = Tcl_DStringValue(&errorBuffer);
  560.         if (strcmp(errfile, sourceName) == 0) {
  561.             errfile = source;
  562.         }
  563.         }
  564.     } else {
  565.         result = TclpDeleteFile(sourceName);
  566.         if (result != TCL_OK) {
  567.         errfile = source;
  568.         }
  569.     }
  570.     if (result != TCL_OK) {
  571.         Tcl_AppendResult(interp, "can't unlink \"", errfile, "\": ",
  572.             Tcl_PosixError(interp), (char *) NULL);
  573.         errfile = NULL;
  574.     }
  575.     }
  576.     
  577.     done:
  578.     if (errfile != NULL) {
  579.     Tcl_AppendResult(interp, 
  580.         ((copyFlag) ? "error copying \"" : "error renaming \""),
  581.         source, (char *) NULL);
  582.     if (errfile != source) {
  583.         Tcl_AppendResult(interp, "\" to \"", target, (char *) NULL);
  584.         if (errfile != target) {
  585.         Tcl_AppendResult(interp, "\": \"", errfile, (char *) NULL);
  586.         }
  587.     }
  588.     Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp),
  589.         (char *) NULL);
  590.     }
  591.     Tcl_DStringFree(&errorBuffer);
  592.     Tcl_DStringFree(&sourcePath);
  593.     Tcl_DStringFree(&targetPath);
  594.     return result;
  595. }
  596.  
  597. /*
  598.  *---------------------------------------------------------------------------
  599.  *
  600.  * FileForceOption --
  601.  *
  602.  *    Helps parse command line options for file commands that take
  603.  *    the "-force" and "--" options.
  604.  *
  605.  * Results:
  606.  *    The return value is how many arguments from argv were consumed
  607.  *    by this function, or -1 if there was an error parsing the
  608.  *    options.  If an error occurred, an error message is left in
  609.  *    interp->result.
  610.  *
  611.  * Side effects:
  612.  *    None.
  613.  *
  614.  *---------------------------------------------------------------------------
  615.  */
  616.  
  617. static int
  618. FileForceOption(interp, argc, argv, forcePtr)
  619.     Tcl_Interp *interp;        /* Interp, for error return. */
  620.     int argc;            /* Number of arguments. */
  621.     char **argv;        /* Argument strings.  First command line
  622.     option, if it exists, begins at */
  623.     int *forcePtr;        /* If the "-force" was specified, *forcePtr
  624.                  * is filled with 1, otherwise with 0. */
  625. {
  626.     int force, i;
  627.     
  628.     force = 0;
  629.     for (i = 0; i < argc; i++) {
  630.     if (argv[i][0] != '-') {
  631.         break;
  632.     }
  633.     if (strcmp(argv[i], "-force") == 0) {
  634.         force = 1;
  635.     } else if (strcmp(argv[i], "--") == 0) {
  636.         i++;
  637.         break;
  638.     } else {
  639.         Tcl_AppendResult(interp, "bad option \"", argv[i], 
  640.             "\": should be -force or --", (char *)NULL);
  641.         return -1;
  642.     }
  643.     }
  644.     *forcePtr = force;
  645.     return i;
  646. }
  647. /*
  648.  *---------------------------------------------------------------------------
  649.  *
  650.  * FileBasename --
  651.  *
  652.  *    Given a path in either tcl format (with / separators), or in the
  653.  *    platform-specific format for the current platform, return all the
  654.  *    characters in the path after the last directory separator.  But,
  655.  *    if path is the root directory, returns no characters.
  656.  *
  657.  * Results:
  658.  *    Appends the string that represents the basename to the end of
  659.  *    the specified initialized DString, returning a pointer to the
  660.  *    resulting string.  If there is an error, an error message is left
  661.  *    in interp, NULL is returned, and the Tcl_DString is unmodified.
  662.  *
  663.  * Side effects:
  664.  *    None.
  665.  *
  666.  *---------------------------------------------------------------------------
  667.  */
  668.  
  669. static char *
  670. FileBasename(interp, path, bufferPtr)
  671.     Tcl_Interp *interp;        /* Interp, for error return. */
  672.     char *path;            /* Path whose basename to extract. */
  673.     Tcl_DString *bufferPtr;    /* Initialized DString that receives
  674.                  * basename. */
  675. {
  676.     int argc;
  677.     char **argv;
  678.     
  679.     Tcl_SplitPath(path, &argc, &argv);
  680.     if (argc == 0) {
  681.     Tcl_DStringInit(bufferPtr);
  682.     } else {
  683.     if ((argc == 1) && (*path == '~')) {
  684.         Tcl_DString buffer;
  685.         
  686.         ckfree((char *) argv);
  687.         path = Tcl_TranslateFileName(interp, path, &buffer);
  688.         if (path == NULL) {
  689.         return NULL;
  690.         }
  691.         Tcl_SplitPath(path, &argc, &argv);
  692.         Tcl_DStringFree(&buffer);
  693.     }
  694.     Tcl_DStringInit(bufferPtr);
  695.  
  696.     /*
  697.      * Return the last component, unless it is the only component, and it
  698.      * is the root of an absolute path.
  699.      */
  700.  
  701.     if (argc > 0) {
  702.         if ((argc > 1)
  703.             || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) {
  704.         Tcl_DStringAppend(bufferPtr, argv[argc - 1], -1);
  705.         }
  706.     }
  707.     }
  708.     ckfree((char *) argv);
  709.     return Tcl_DStringValue(bufferPtr);
  710. }
  711.  
  712. /*
  713.  *----------------------------------------------------------------------
  714.  *
  715.  * TclFileAttrsCmd --
  716.  *
  717.  *      Sets or gets the platform-specific attributes of a file. The objc-objv
  718.  *    points to the file name with the rest of the command line following.
  719.  *    This routine uses platform-specific tables of option strings
  720.  *    and callbacks. The callback to get the attributes take three
  721.  *    parameters:
  722.  *        Tcl_Interp *interp;        The interp to report errors with.
  723.  *                    Since this is an object-based API,
  724.  *                    the object form of the result should be
  725.  *                    used.
  726.  *        CONST char *fileName;   This is extracted using
  727.  *                    Tcl_TranslateFileName.
  728.  *        TclObj **attrObjPtrPtr; A new object to hold the attribute
  729.  *                    is allocated and put here.
  730.  *    The first two parameters of the callback used to write out the
  731.  *    attributes are the same. The third parameter is:
  732.  *        CONST *attrObjPtr;        A pointer to the object that has
  733.  *                    the new attribute.
  734.  *    They both return standard TCL errors; if the routine to get
  735.  *    an attribute fails, no object is allocated and *attrObjPtrPtr
  736.  *    is unchanged.
  737.  *
  738.  * Results:
  739.  *      Standard TCL error.
  740.  *
  741.  * Side effects:
  742.  *      May set file attributes for the file name.
  743.  *      
  744.  *----------------------------------------------------------------------
  745.  */
  746.  
  747. int
  748. TclFileAttrsCmd(interp, objc, objv)
  749.     Tcl_Interp *interp;        /* The interpreter for error reporting. */
  750.     int objc;            /* Number of command line arguments. */
  751.     Tcl_Obj *CONST objv[];    /* The command line objects. */
  752. {
  753.     Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
  754.     char *fileName;
  755.     int length, index;
  756.     Tcl_Obj *listObjPtr;
  757.     Tcl_Obj *elementObjPtr;
  758.     Tcl_DString buffer;
  759.  
  760.     if ((objc > 2) && ((objc % 2) == 0)) {
  761.     Tcl_AppendStringsToObj(resultPtr, 
  762.         "wrong # args: must be \"file attributes name ?option? ?value? ?option value? ...\"",
  763.         (char *) NULL);
  764.     return TCL_ERROR;
  765.     }
  766.  
  767.     fileName = Tcl_GetStringFromObj(objv[0], &length);
  768.     if (Tcl_TranslateFileName(interp, fileName, &buffer) == NULL) {
  769.         return TCL_ERROR;
  770.     }
  771.     fileName = Tcl_DStringValue(&buffer);
  772.     
  773.     if (objc == 1) {
  774.         listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
  775.         
  776.         for (index = 0; tclpFileAttrStrings[index] != NULL; index++) {
  777.             elementObjPtr = Tcl_NewStringObj(tclpFileAttrStrings[index], -1);
  778.         Tcl_ListObjAppendElement(interp, listObjPtr, elementObjPtr);
  779.         if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName,
  780.                 &elementObjPtr) != TCL_OK) {
  781.             Tcl_DecrRefCount(listObjPtr);
  782.             return TCL_ERROR;
  783.         }
  784.         Tcl_ListObjAppendElement(interp, listObjPtr, elementObjPtr);
  785.         }
  786.         Tcl_SetObjResult(interp, listObjPtr);
  787.     } else if (objc == 2) {
  788.         if (Tcl_GetIndexFromObj(interp, objv[1], tclpFileAttrStrings, "option",
  789.             0, &index) != TCL_OK) {
  790.             return TCL_ERROR;
  791.         }
  792.     if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName,
  793.         &elementObjPtr) != TCL_OK) {
  794.         return TCL_ERROR;
  795.     }
  796.     Tcl_SetObjResult(interp, elementObjPtr);
  797.     } else {
  798.         int i;
  799.         
  800.         for (i = 1; i < objc ; i += 2) {
  801.             if (Tcl_GetIndexFromObj(interp, objv[i], tclpFileAttrStrings, "option",
  802.                     0, &index) != TCL_OK) {
  803.                 return TCL_ERROR;
  804.             }
  805.             if ((*tclpFileAttrProcs[index].setProc)(interp, index, fileName,
  806.                     objv[i + 1]) != TCL_OK) {
  807.                 return TCL_ERROR;
  808.             }
  809.         }
  810.     }
  811.     
  812.     Tcl_DStringFree(&buffer);
  813.     
  814.     return TCL_OK;
  815. }
  816.